home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / scsh / oldtop.scm < prev    next >
Text File  |  1995-10-13  |  4KB  |  134 lines
  1. ;;; Scsh top level
  2. ;;; Copyright (c) 1993 by Olin Shivers.
  3.  
  4. ;;; Requires
  5. ;;;   From BUILD: build-image
  6. ;;;   From COMMAND: start-command-processor, user-context,
  7. ;;;                 package-for-commands
  8.  
  9. (define %internal-full-command-line '())
  10. (define %internal-command-line-arguments '())
  11. (define (command-line) (append %internal-command-line-arguments '()))
  12.  
  13. (define scsh-major-version 0)
  14. (define scsh-minor-version 4)
  15. (define scsh-version-string "0.4.0")
  16.  
  17. ;;; A scsh starter takes the command line args, parses them, 
  18. ;;; initialises the scsh system, and either starts up a repl loop
  19. ;;; or executes the -s script.
  20. (define (make-scsh-starter)
  21.   (let ((env (environment-for-commands))
  22.     (context (user-context)))
  23.     (lambda (args)
  24.       (receive (script args) (parse-scsh-args args)
  25.     (set! command-line-arguments (append args '()))
  26.     (cond (script        ;Batch
  27.            (set! %internal-command-line-arguments
  28.              (cons script args))
  29.            (load-quietly1 script env)
  30.            0)            ; exit code
  31.  
  32.           (else        ; Interactive
  33.            (with-interaction-environment env
  34.              (lambda ()
  35.            (set-batch-mode?! #t)
  36.            (set! %internal-command-line-arguments
  37.              (cons "scsh" args))
  38.            (start-command-processor ""
  39.                         context
  40.                         (lambda ()
  41.                           (display "Scsh ")
  42.                           (display scsh-version-string)
  43.                           (newline)
  44.                           ))))))))))
  45.  
  46. ;;; Make a different kind of starter. This one initialises the
  47. ;;; scsh run time, then simply calls the user's program.
  48. ;;;
  49. ;;; It should take an arg to determine what kind of a condition
  50. ;;; system you'd like in place. 
  51.  
  52. (define (make-top-level main)
  53.   (lambda (args)
  54.     (set! %internal-full-command-line args)
  55.     (set! %internal-command-line-arguments (cons "" args))
  56.     (init-scsh #f #t)
  57.     (set! command-line-arguments (append args '()))
  58.     (main)
  59.     0))
  60.  
  61. (define (repl)
  62.   (command-loop (lambda () (set-batch-mode?! #f))
  63.         #f))
  64.  
  65.  
  66. (define (bad-args arg-list)
  67.   (error "Bad argument list to scsh.
  68. Useage: scsh [<end-option> <arg1> ... <argn>]
  69. <end-option>: -s <script-file>
  70.               --  (Terminates option parsing)" arg-list))
  71.  
  72. (define (parse-scsh-args arg-list)
  73.   (if (pair? arg-list)
  74.       (let ((arg1 (car arg-list))
  75.         (rest (cdr arg-list)))
  76.     (cond ((string=? arg1 "-s")
  77.            (if (pair? rest)
  78.            (values (car rest) (cdr rest))
  79.            (bad-args arg-list)))
  80.           ((string=? arg1 "--") (values #f rest))
  81.           (else (bad-args arg-list))))
  82.       (values #f '())))
  83.       
  84.  
  85. ;;; BUILD-IMAGE calls the starter after installing a fatal top-level
  86. ;;; error handler. MAKE-SCSH-STARTER shadows it in the interactive case.
  87.  
  88. (define (dump-scsh fname)
  89.   (build-scsh-image (make-scsh-starter) fname))
  90.  
  91. (define (dump-scsh-program main fname)
  92.   (build-scsh-image main fname))
  93.  
  94. ;;; Hacked because s48's compiler's scanner insists on echoing the file name.
  95.  
  96. (define (load-quietly1 fname package)
  97.   (call-with-input-file fname
  98.     (lambda (port)
  99.       (let loop ()
  100.     (let ((form (read port)))
  101.       (if (not (eof-object? form))
  102.           (begin (eval form package)
  103.              (loop))))))))
  104.  
  105. ;;; Had to define these as the ones in s48's build.scm do not properly
  106. ;;; initialise ERROR-OUTPUT-PORT to stderr -- this is a bug in the vm's
  107. ;;; handoff to the very first Scheme form (it passes two ports -- not three).
  108. ;;; Until Kelsey fixes these, we hack it with these replacements, which
  109. ;;; invoke INIT-SCSH, which re-initialises the I/O system to be what
  110. ;;; you wanted.
  111.  
  112. (define (build-scsh-image start filename)
  113.   (let ((filename (translate filename)))
  114.     (display (string-append "Writing " filename) (command-output))
  115.     (newline (command-output))
  116.     (flush-the-symbol-table!)    ;Gets restored at next use of string->symbol
  117.     (write-image filename
  118.          (scsh-stand-alone-resumer start)
  119.          "")
  120.     #t))
  121.  
  122. (define (scsh-stand-alone-resumer start)
  123.   (usual-resumer  ;sets up exceptions, interrupts, and current input & output
  124.    (lambda (args)
  125.      (init-scsh #f #f)    ; Whatever. Install scsh's I/O system.
  126.      (call-with-current-continuation
  127.        (lambda (halt)
  128.      (set! command-line-arguments (append args '()))
  129.      (set! %internal-full-command-line args)
  130.      (set! %internal-command-line-arguments (cons "" args))    ; WRONG
  131.      (with-handler (simple-condition-handler halt (error-output-port))
  132.        (lambda ()
  133.          (start args))))))))
  134.